Turnbull China Bikeride/Turnbull China Bikeride - Disc 2.iso/STUTTGART/LANG/ADA/GNAT/!gcc/adainc/4/adb/s-fileio

Text File | 1996-02-12 | 28KB | 937 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . F I L E _ I O                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.30 $                             --
--                                                                          --
--   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Finalization;            use Ada.Finalization;
with Ada.IO_Exceptions;           use Ada.IO_Exceptions;
with Ada.Streams;                 use Ada.Streams;
with Interfaces.C_Streams;        use Interfaces.C_Streams;
with System.Tasking_Soft_Links;   use System.Tasking_Soft_Links;
with Unchecked_Deallocation;

package body System.File_IO is

   use System.File_Control_Block;

   ----------------------
   -- Global Variables --
   ----------------------

   Open_Files : AFCB_Ptr;
   --  This points to a list of AFCB's for all open files. This is a doubly
   --  linked list, with the Prev pointer of the first entry, and the Next
   --  pointer of the last entry containing null.

   type Temp_File_Record;
   type Temp_File_Record_Ptr is access all Temp_File_Record;

   Temp_Base : constant String := "ADA_TEMP_";

   Temp_Len : constant := Temp_Base'Length + 6;
   --  Length of temporary file name (6 = length of suffix added by mktemp)
   --  This does not include the terminating NUL character.

   type Temp_File_Record is record
      Name : String (1 .. Temp_Len + 1);
      Next : Temp_File_Record_Ptr;
   end record;
   --  One of these is allocated for each temporary file created

   Temp_Files : Temp_File_Record_Ptr;
   --  Points to list of names of temporary files

   type File_IO_Clean_Up_Type is new Controlled with null record;
   --  The closing of all open files and deletion of temporary files is an
   --  action which takes place at the end of execution of the main program.
   --  This action can be implemented using a library level object which
   --  gets finalized at the end of the main program execution. The above is
   --  a controlled type introduced for this purpose.

   procedure Finalize (V : in out File_IO_Clean_Up_Type);
   --  This is the finalize operation that is used to do the cleanup.

   File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
   --  This is the single object of the type that triggers the finalization
   --  call. Since it is at the library level, this happens just before the
   --  environment task is finalized.

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Free_String is new Unchecked_Deallocation (String, Pstring);

   subtype Fopen_String is String (1 .. 4);
   --  Holds open string (longest is "w+b" & nul)

   procedure Fopen_Mode
     (Mode    : File_Mode;
      Text    : Boolean;
      Creat   : Boolean;
      Amethod : Character;
      Fopstr  : out Fopen_String);
   --  Determines proper open mode for a file to be opened in the given
   --  Ada mode. Text is true for a text file and false otherwise, and
   --  Creat is true for a create call, and False for an open call. The
   --  value stored in Fopstr is a nul-terminated string suitable for a
   --  call to fopen or freopen. Amethod is the character designating
   --  the access method from the Access_Method field of the FCB.

   ---------------------
   -- Check_File_Open --
   ---------------------

   procedure Check_File_Open (File : AFCB_Ptr) is
   begin
      if File = null then
         raise Status_Error;
      end if;
   end Check_File_Open;

   ----------------
   -- Append_Set --
   ----------------

   procedure Append_Set (File : AFCB_Ptr) is
   begin
      if File.Mode = Append_File then
         if fseek (File.Stream, 0, SEEK_END) /= 0 then
            raise Device_Error;
         end if;
      end if;
   end Append_Set;

   ----------------
   -- Chain_File --
   ----------------

   procedure Chain_File (File : AFCB_Ptr) is
   begin
      File.Next := Open_Files;
      File.Prev := null;
      Open_Files := File;

      if File.Next /= null then
         File.Next.Prev := File;
      end if;
   end Chain_File;

   -----------------------
   -- Check_Read_Status --
   -----------------------

   procedure Check_Read_Status (File : AFCB_Ptr) is
   begin
      if File = null then
         raise Status_Error;
      elsif File.Mode > Inout_File then
         raise Mode_Error;
      end if;
   end Check_Read_Status;

   ------------------------
   -- Check_Write_Status --
   ------------------------

   procedure Check_Write_Status (File : AFCB_Ptr) is
   begin
      if File = null then
         raise Status_Error;
      elsif File.Mode = In_File then
         raise Mode_Error;
      end if;
   end Check_Write_Status;

   -----------
   -- Close --
   -----------

   procedure Close (File : in out AFCB_Ptr) is
      Close_Status : int := 0;

   begin
      Check_File_Open (File);
      AFCB_Close (File);

      --  Sever the association between the given file and its associated
      --  external file. The given file is left closed. Do not perform system
      --  closes on the standard input, output and error files and also do
      --  not attempt to close a stream that does not exist (signalled by a
      --  null stream value -- happens in some error situations).

      if not File.Is_System_File
        and then File.Stream /= NULL_Stream
      then
         Close_Status := fclose (File.Stream);
      end if;

      --  Dechain file from list of open files and then free the storage
      --  Since this is a global data structure, we have to protect against
      --  multiple tasks attempting to access this list.

      Lock_Task;

      if File.Prev = null then
         Open_Files := File.Next;
      else
         File.Prev.Next := File.Next;
      end if;

      if File.Next /= null then
         File.Next.Prev := File.Prev;
      end if;

      Unlock_Task;

      --  Deallocate some parts of the file structure that were kept in heap
      --  storage with the exception of system files (standard input, output
      --  and error) since they had some information allocated in the stack.

      if not File.Is_System_File then
         Free_String (File.Name);
         Free_String (File.Form);
         AFCB_Free (File);
      end if;

      File := null;

      if Close_Status /= 0 then
         raise Device_Error;
      end if;
   end Close;

   ------------
   -- Delete --
   ------------

   procedure Delete (File : in out AFCB_Ptr) is
   begin
      Check_File_Open (File);

      if not File.Is_Regular_File then
         raise Use_Error;
      end if;

      declare
         Filename : aliased constant String := File.Name.all;

      begin
         Close (File);

         if unlink (Filename'Address) = -1 then
            raise Use_Error;
         end if;
      end;
   end Delete;

   -----------------
   -- End_Of_File --
   -----------------

   function End_Of_File (File : AFCB_Ptr) return Boolean is
   begin
      Check_File_Open (File);

      if feof (File.Stream) /= 0 then
         return True;

      else
         Check_Read_Status (File);

         if ungetc (fgetc (File.Stream), File.Stream) = EOF then
            clearerr (File.Stream);
            return True;
         else
            return False;
         end if;
      end if;
   end End_Of_File;

   --------------
   -- Finalize --
   --------------

   --  Note: we do not need to worry about locking against multiple task
   --  access in this routine, since it is called only from the environment
   --  task just before terminating execution.

   procedure Finalize (V : in out File_IO_Clean_Up_Type) is
      Discard : int;
      Fptr1   : AFCB_Ptr;
      Fptr2   : AFCB_Ptr;
   begin
      --  First close all open files (the slightly complex form of this loop
      --  is required because Close as a side effect nulls out its argument)

      Fptr1 := Open_Files;
      while Fptr1 /= null loop
         Fptr2 := Fptr1.Next;
         Close (Fptr1);
         Fptr1 := Fptr2;
      end loop;

      --  Now unlink all temporary files. We do not bother to free the
      --  blocks because we are just about to terminate the program. We
      --  also ignore any errors while attempting these unlink operations.

      while Temp_Files /= null loop
         Discard := unlink (Temp_Files.Name'Address);
         Temp_Files := Temp_Files.Next;
      end loop;

   end Finalize;

   -----------
   -- Flush --
   -----------

   procedure Flush (File : AFCB_Ptr) is
   begin
      Check_Write_Status (File);

      if fflush (File.Stream) = 0 then
         return;
      else
         raise Device_Error;
      end if;
   end Flush;

   ----------------
   -- Fopen_Mode --
   ----------------

   --  The fopen mode to be used is shown by the following table:

   --                                     OPEN         CREATE
   --     Append_File                     "r+"           "w+"
   --     In_File                         "r"            "w+"
   --     Out_File (Direct_IO)            "r+"           "w"
   --     Out_File (all others)           "w"            "w"
   --     Inout_File                      "r+"           "w+"

   --  Note: we do not use "a" or "a+" for Append_File, since this would not
   --  work in the case of stream files, where even if in append file mode,
   --  you can reset to earlier points in the file. The caller must use the
   --  Append_Set routine to deal with the necessary positioning.

   --  Note: in several cases, the fopen mode used allows reading and
   --  writing, but the setting of the Ada mode is more restrictive. For
   --  instance, Create in In_File mode uses "r+" which allows writing,
   --  but the Ada mode In_File will cause any write operations to be
   --  rejected with Mode_Error in any case.

   --  Note: for the Out_File/Open cases for other than the Direct_IO case,
   --  an initial call will be made by the caller to first open the file in
   --  "r" mode to be sure that it exists. The real open, in "w" mode, will
   --  then destroy this file. This is peculiar, but that's what Ada semantics
   --  require and the ACVT tests insist on!

   --  If text file translation is required, then either b or t is
   --  added to the mode, depending on the setting of Text.

   procedure Fopen_Mode
     (Mode    : File_Mode;
      Text    : Boolean;
      Creat   : Boolean;
      Amethod : Character;
      Fopstr  : out Fopen_String)
   is
      Fptr  : Positive;

      text_translation_required : Boolean;
      pragma Import (C, text_translation_required);

   begin
      case Mode is
         when In_File =>
            if Creat then
               Fopstr (1) := 'w';
               Fopstr (2) := '+';
               Fptr := 3;
            else
               Fopstr (1) := 'r';
               Fptr := 2;
            end if;

         when Out_File =>
            if Amethod = 'D' and not Creat then
               Fopstr (1) := 'r';
               Fopstr (2) := '+';
               Fptr := 3;
            else
               Fopstr (1) := 'w';
               Fptr := 2;
            end if;

         when Inout_File | Append_File =>
            if Creat then
               Fopstr (1) := 'w';
            else
               Fopstr (1) := 'r';
            end if;

            Fopstr (2) := '+';
            Fptr := 3;

      end case;

      --  If text_translation_required is true then we need to append
      --  either a t or b to the string to get the right mode

      if text_translation_required then
         if Text then
            Fopstr (Fptr) := 't';
         else
            Fopstr (Fptr) := 'b';
         end if;

         Fptr := Fptr + 1;
      end if;

      Fopstr (Fptr) := Ascii.NUL;
   end Fopen_Mode;

   ----------
   -- Form --
   ----------

   function Form (File : in AFCB_Ptr) return String is
   begin
      if File = null then
         raise Status_Error;
      else
         return File.Form.all (1 .. File.Form'Length - 1);
      end if;
   end Form;

   ------------------
   -- Form_Boolean --
   ------------------

   function Form_Boolean
     (Form    : String;
      Keyword : String;
      Default : Boolean)
      return    Boolean
   is
      V1, V2 : Natural;

   begin
      Form_Parameter (Form, Keyword, V1, V2);

      if V1 = 0 then
         return Default;

      elsif Form (V1) = 'y' then
         return True;

      elsif Form (V1) = 'n' then
         return False;

      else
         raise Use_Error;
      end if;
   end Form_Boolean;

   ------------------
   -- Form_Integer --
   ------------------

   function Form_Integer
     (Form    : String;
      Keyword : String;
      Default : Integer)
      return    Integer
   is
      V1, V2 : Natural;
      V      : Integer;

   begin
      Form_Parameter (Form, Keyword, V1, V2);

      if V1 = 0 then
         return Default;

      else
         V := 0;

         for J in V1 .. V2 loop
            if Form (J) not in '0' .. '9' then
               raise Use_Error;
            else
               V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
            end if;

            if V > 999_999 then
               raise Use_Error;
            end if;
         end loop;

         return V;
      end if;
   end Form_Integer;

   --------------------
   -- Form_Parameter --
   --------------------

   procedure Form_Parameter
     (Form    : String;
      Keyword : String;
      Start   : out Natural;
      Stop    : out Natural)
  is

      Klen : constant Integer := Keyword'Length;

   --  Start of processing for Form_Parameter

   begin
      for J in Form'First + Klen .. Form'Last - 1 loop
         if Form (J) = '='
           and then Form (J - Klen .. J - 1) = Keyword
         then
            Start := J + 1;
            Stop := Start - 1;

            while Form (Stop + 1) /= Ascii.NUL
              and then Form (Stop + 1) /= ','
            loop
               Stop := Stop + 1;
            end loop;

            return;
         end if;
      end loop;

      Start := 0;
   end Form_Parameter;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (File : in AFCB_Ptr) return Boolean is
   begin
      return (File /= null);
   end Is_Open;

   ----------
   -- Mode --
   ----------

   function Mode (File : in AFCB_Ptr) return File_Mode is
   begin
      if File = null then
         raise Status_Error;
      else
         return File.Mode;
      end if;
   end Mode;

   ----------
   -- Name --
   ----------

   function Name (File : in AFCB_Ptr) return String is
   begin
      if File = null then
         raise Status_Error;
      else
         return File.Name.all (1 .. File.Name'Length - 1);
      end if;
   end Name;

   ----------
   -- Open --
   ----------

   procedure Open
     (File_Ptr  : in out AFCB_Ptr;
      Dummy_FCB : in out AFCB'Class;
      Mode      : File_Mode;
      Name      : String;
      Form      : String;
      Amethod   : Character;
      Creat     : Boolean;
      Text      : Boolean;
      C_Stream  : FILEs := NULL_Stream)
   is
      Stream : FILEs := C_Stream;
      --  Stream which we open in response to this request

      Shared : Shared_Status_Type;
      --  Setting of Shared_Status field for file

      Fopstr : aliased Fopen_String;
      --  Mode string used in fopen call

      Fmoder : aliased constant String (1 .. 2) := "r" & Ascii.NUL;
      --  Used for test open to see if file exists

      Formstr : aliased String (1 .. Form'Length + 1);
      --  Form string with Ascii.NUL appended, folded to lower case

      Tempfile : constant Boolean := (Name'Length = 0);
      --  Indicates temporary file case

      Namelen : constant Integer := Integer'Max (Temp_Len, Name'Length);
      --  Length required for file name, not including final Ascii.NUL

      Namestr : aliased String (1 .. Namelen + 1);
      --  Name as given or temporary file name with Ascii.NUL appended

      Fullname : aliased String (1 .. max_path_len + 1);
      --  Full name (as required for Name function, and as stored in the
      --  control block in the Name field) with Ascii.NUL appended.

      Full_Name_Len : Integer;
      --  Length of name actually stored in Fullname

   begin
      if File_Ptr /= null then
         raise Status_Error;
      end if;

      --  Acquire form string, setting required NUL terminator

      Formstr (1 .. Form'Length) := Form;
      Formstr (Formstr'Last) := Ascii.NUL;

      --  Convert form string to lower case

      for J in Formstr'Range loop
         if Formstr (J) in 'A' .. 'Z' then
            Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
         end if;
      end loop;

      --  Acquire setting of shared parameter

      declare
         V1, V2 : Natural;

      begin
         Form_Parameter (Formstr, "shared", V1, V2);

         if V1 = 0 then
            Shared := None;

         elsif Formstr (V1 .. V2) = "yes" then
            Shared := Yes;

         elsif Formstr (V1 .. V2) = "no" then
            Shared := No;

         else
            raise Use_Error;
         end if;
      end;

      --  Remaining processing is done with tasking locked out. This ensures
      --  that the global data structures (temporary file chain and the open
      --  file chain) retain their integrity.

      Lock_Task;

      --  If we were given a stream (call from xxx.C_Streams.Open), then set
      --  full name to null and that is all we have to do in this case so
      --  skip to end of processing.

      if Stream /= NULL_Stream then
         Fullname (1) := Ascii.Nul;
         Full_Name_Len := 1;

      --  Normal case of Open or Create

      else
         --  If temporary file case, get temporary file name and add
         --  to the list of temporary files to be deleted on exit.

         if Tempfile then
            if not Creat then
               Unlock_Task;
               raise Name_Error;
            end if;

            Namestr := Temp_Base & "XXXXXX" & Ascii.NUL;
            mktemp (Namestr'Address);

            if Namestr (1) = Ascii.NUL then
               Unlock_Task;
               raise Use_Error;
            end if;

            Temp_Files :=
              new Temp_File_Record'(Name => Namestr, Next => Temp_Files);

         --  Normal case of non-null name given

         else
            Namestr (1 .. Name'Length) := Name;
            Namestr (Name'Length + 1)  := Ascii.NUL;
         end if;

         --  Get full name in accordance with the advice of RM A.8.2(22).

         full_name (Namestr'Address, Fullname'Address);

         for J in Fullname'Range loop
            if Fullname (J) = Ascii.NUL then
               Full_Name_Len := J;
               exit;
            end if;
         end loop;

         --  If Shared=None or Shared=Yes, then check for the existence
         --  of another file with exactly the same full name.

         if Shared /= No then
            declare
               P : AFCB_Ptr;

            begin
               P := Open_Files;
               while P /= null loop
                  if Fullname (1 .. Full_Name_Len) = P.Name.all then

                     --  If we get a match, and either file has Shared=None,
                     --  then raise Use_Error, since we don't allow two files
                     --  of the same name to be opened unless they specify the
                     --  required sharing mode.

                     if Shared = None
                       or else P.Shared_Status = None
                     then
                        Unlock_Task;
                        raise Use_Error;

                     --  If both files have Shared=Yes, then we acquire the
                     --  stream from the located file to use as our stream.

                     elsif Shared = Yes
                       and then P.Shared_Status = Yes
                     then
                        Stream := P.Stream;
                        exit;

                     --  Otherwise one of the files has Shared=Yes and one
                     --  has Shared=No. If the current file has Shared=No
                     --  then all is well but we don't want to share any
                     --  other file's stream. If the current file has
                     --  Shared=Yes, we would like to share a stream, but
                     --  not from a file that has Shared=No, so in either
                     --  case we just keep going on the search.

                     else
                        null;
                     end if;
                  end if;

                  P := P.Next;
               end loop;
            end;
         end if;

         --  Open specified file if we did not find an existing stream

         if Stream = NULL_Stream then
            Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);

            --  A special case, if we are opening (OPEN case) a file and
            --  the mode returned by Fopen_Mode is not "r" or "r+", then
            --  we first do an open in "r" mode to make sure that the file
            --  exists as required by Ada semantics, we then reopen in the
            --  required mode.

            if Creat = False and then Fopstr (1) /= 'r' then
               Stream := fopen (Namestr'Address, Fmoder'Address);

               if Stream = NULL_Stream then
                  Unlock_Task;
                  raise Name_Error;
               else
                  Stream := freopen (Namestr'Address, Fopstr'Address, Stream);
               end if;

            --  Normal case, we can open the file directly with the given mode

            else
               Stream := fopen (Namestr'Address, Fopstr'Address);
            end if;

            if Stream = NULL_Stream then
               Unlock_Task;
               raise Name_Error;
            end if;
         end if;
      end if;

      --  Stream has been successfully located or opened, so now we are
      --  committed to completing the opening of the file. Allocate block
      --  on heap and fill in its fields.

      File_Ptr := AFCB_Allocate (Dummy_FCB);

      File_Ptr.Is_Regular_File   := (is_regular_file (fileno (Stream)) /= 0);
      File_Ptr.Is_System_File    := False;
      File_Ptr.Is_Text_File      := Text;
      File_Ptr.Shared_Status     := Shared;
      File_Ptr.Access_Method     := Amethod;
      File_Ptr.Stream            := Stream;
      File_Ptr.Form              := new String'(Formstr);
      File_Ptr.Name              := new String'(Fullname (1 .. Full_Name_Len));
      File_Ptr.Mode              := Mode;
      File_Ptr.Is_Temporary_File := False;

      Chain_File (File_Ptr);
      Unlock_Task;
      Append_Set (File_Ptr);
   end Open;

   --------------
   -- Read_Buf --
   --------------

   procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
      Nread : size_t;

   begin
      Nread := fread (Buf, 1, Siz, File.Stream);

      if Nread = Siz then
         return;

      elsif ferror (File.Stream) /= 0 then
         raise Device_Error;

      elsif Nread = 0 then
         raise End_Error;

      else -- 0 < Nread < Siz
         raise Data_Error;
      end if;

   end Read_Buf;

   procedure Read_Buf
     (File  : AFCB_Ptr;
      Buf   : Address;
      Siz   : in Interfaces.C_Streams.size_t;
      Count : out Interfaces.C_Streams.size_t)
   is
   begin
      Count := fread (Buf, 1, Siz, File.Stream);

      if Count = 0 and then ferror (File.Stream) /= 0 then
         raise Device_Error;
      end if;
   end Read_Buf;

   -----------
   -- Reset --
   -----------

   --  The reset which does not change the mode simply does a rewind.

   procedure Reset (File : in out AFCB_Ptr) is
   begin
      Check_File_Open (File);
      rewind (File.Stream);
   end Reset;

   --  The reset with a change in mode is done using freopen, and is
   --  not permitted except for regular files (since otherwise there
   --  is no name for the freopen, and in any case it seems meaningless)

   procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is
      Fopstr : aliased Fopen_String;

   begin
      Check_File_Open (File);

      --  If mode is not really changing, then we simply rewind the stream
      --  this is permitted in all cases except for non-regular files, where
      --  rewind can't work.

      if Mode = File.Mode and then File.Is_Regular_File then

         if Mode /= Append_File then
            rewind (File.Stream);
         end if;

      --  Change of mode not allowed for shared file or file with no name
      --  or file that is not a regular file, or for a system file.

      elsif File.Shared_Status = Yes
        or else File.Name'Length <= 1
        or else File.Is_System_File
        or else (not File.Is_Regular_File)
      then
         raise Use_Error;

      --  Here the change of mode is permitted, we do it by reopening the
      --  file in the new mode and replacing the stream with a new stream.

      else
         Fopen_Mode
           (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);

         File.Stream :=
           freopen (File.Name.all'Address, Fopstr'Address, File.Stream);

         if File.Stream = NULL_Stream then
            Close (File);
            raise Use_Error;

         else
            File.Mode := Mode;
            Append_Set (File);
         end if;
      end if;
   end Reset;

   ---------------
   -- Write_Buf --
   ---------------

   procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
   begin
      if fwrite (Buf, 1, Siz, File.Stream) /= Siz then
         raise Device_Error;
      end if;
   end Write_Buf;

end System.File_IO;